

;; function.lsp
;; contains new functions and modifications of Tierney functions.
;; Copyright (c) 1991-2002 by Forrest W. Young

(defun where (arg1 arg2) 
  (which (map-elements `,arg1 arg2)))

(defun written-time (time-in-decimal-minutes)
  (let* ((time time-in-decimal-minutes)
         (hours   (floor (mod (/ time 60) 60)))
         (minutes (floor time))
         (seconds (floor (* 60 (rem time 1))))
         (60ths   (round (mod (* 60 time) 60)))
         (str)
         )
    (when (> hours 0) (setf str (format nil "~d hours, " hours)))
    (when (or (> hours 0) (> minutes 0))
          (setf str (strcat str (format nil "~d minutes, " minutes))))
    (setf str (strcat str (format nil " ~d and ~d/60 seconds" seconds 60ths)))
    str))


(defun run-time (&key long-hand wordy) 
"Arg: wordy
Returns run time in minutes. Expressed in words when WORDY is true."
  (let ((time  (fuzz (/ (get-internal-real-time) internal-time-units-per-second 60) 2)))
    (if long-hand (written-time time) time)))


 (defun odd-p (i)
     (= 1 (mod i 2)))

 (defun odd (i)
     (= 1 (mod i 2)))

 (defun even-p (i)
     (= 0 (mod i 2)))

 (defun even (i)
     (= 0 (mod i 2)))

(defun word-wrap (text &optional (w t) (max-length 80) (nlines 0))
  (cond
    ((> (length text) max-length)
     (let* ((m (position #\newline text))
            (m (if m m (1- (length text))))
            (n (position #\space (reverse (select text (iseq max-length)))))
            (n (if n (- max-length n) max-length))
            (first-string (select text (iseq (min n m))))
            (second-string (select text (iseq (min n (1+ m)) (max m (1- (length text)))))))
       (display-string (format nil "~a~%" first-string) w)
       (word-wrap second-string w max-length)
       ))
    (t
     (display-string (format nil "~a~%" text) w))))
   


(defun remove-trailing-blanks (str)
     (if (equal (string (select (reverse str) 0)) " ")
         (progn 
          (setf str (reverse (select (reverse str) (iseq 1 (1- (length str))))))
          (remove-trailing-blanks str))
         str))

(defun positions (element list)
"Args: element list
Finds all positions of element in list"
    (which (map-elements #'equal element list)))

(defun remove-elements (elements-list target-list)
"Args: list-a list-b
non-destructively removes elements of list-a from list-b, if present"
    (let ((new-list (copy-list target-list)))
      (dotimes (i (length elements-list))
               (setf new-list (remove (select elements-list i)
                                         new-list)))
      new-list))

#|moved next six functions to generic.lsp fwy 09-28-02

(defun new-edit ()
"Args: none
New edit opens the Lisp Editor and creates a new file for editing"
    (system (strcat *default-path* "lspedit.exe")))

(defun reedit-data (&optional (dash *current-datasheet*))
  (if dash (send dash :show-window) (error "There are no previously edited data.")))

(defun show-datasheet (&optional (dash *current-datasheet*))
  (if dash (send dash :show-window) (error "There is no datasheet.")))

(defun show-lispedit ()
  (new-edit))

(defun open-file (&rest args) 
"ARGS: &REST ARGS. Alias for Lisp function OPEN"
	(apply #'open args))

(defun open-edit (&optional file) 
"Args: (&optional file)
Open an editing window containing the file ready for editing by the LispEdit application. If the optional string argument FILE is included, the file is opened, otherwise a dialog is presented to select the file. The string need not end with .lsp.  Returns the file name."
  (let ((dir (get-working-directory))
        (lispedit (strcat *default-path* "lspedit.exe   "))
        (short-filename)
        )
    (when (not file)
          (set-working-directory *open-edit-here-directory*) 
          (setf file (read-file-dialog t))
          (send *workmap* :redraw))
    (when file
          (setf *open-edit-here-directory* (get-working-directory))
          (set-working-directory *open-edit-here-directory*)
          (setf short-filename (pathless-file-namestring file))
          (system (strcat lispedit short-filename)))
    file))
|#

(defun pathless-file-namestring (file-namestring)
  (reverse (subseq (reverse file-namestring) 
                   0 (position #\\ (reverse file-namestring)))))

(defconstant ! "!") ;wildcard constant

(defun integer-listp (list)
    (= (length (which (mapcar #'integerp list))) (length list)))

(defun non-missing (var) 
  (select var (which (map-elements 'not (map-elements 'equal nil var)))))

(defun id-non-missing (var)
  "Args: VAR. Takes a var con missing values and gives the position of  them "
  (which (map-elements 'not (map-elements 'equal nil var))))

(defun function-with-missing (f data &optional args)
  "Args: F a function that returns a list or a vector as a result. DATA a list or a vector.
&optional args. A list with optional args for the function F. Returns the results of function for the non-nil elements of data. NIL elements are returned untouched. Example (function-with-missing (#'log data (list 10)) will return log base 10 for data."
    (let ( (data (copy-list data))
           (args args)
           (f f))
      (setf (select data (id-non-missing data)) (apply f (non-missing data) args)) data)
  )

(defun string-product (strlist1 strlist2 &key reverse)
"Args: strlist1 strlist2 &key reverse
Returns the outer product of two lists of strings, where outer product is all combinations of str1*str2. Returns str2*str1 when reverse is t."
  (let* ((L1 (length strlist1))
        (L2 (length strlist2))
        (k 0)
        (product (repeat strlist1 L2))
        )
    (dotimes (i L2)
             (dotimes (j L1)
                      (setf (select product k) 
                            (if reverse
                                (strcat (select strlist2 i) "*" (select product  k))
                                (strcat (select product  k) "*" (select strlist2 i))))
                      (setf k (1+ k))))
    product))


(defun string-list (strlist1 strlist2 &key reverse)
"Args: strlist1 strlist2 &key reverse
Returns a list of lists where there is a sublist for each combination of lists."
  (let* ((L1 (length strlist1))
        (L2 (length strlist2))
        (k 0)
        (result (repeat strlist1 L2))
        )
    (dotimes (i L2)
             (dotimes (j L1)
                      (setf (select result k) 
                            (if reverse
                                (combine (select strlist2 i) (select result   k))
                                (combine (select result   k) (select strlist2 i))))
                      (setf k (1+ k))))
    result))

(defun printlist (list) (format t "~%~A" list))

(defun do-nothing ())

(defun radians (deg) (/ (* deg pi) 360))

;print-matrix-to-window moved to reportw.lsp


(defun gensym2 (&optional symbol-name val)
"Args: SYMBOL-NAME VAL
Redefines gensym to return a particular string with a particular value. If the two optional arguments are not specified, the function just performs a GENSYM."
  (if val 
      (let* (
            (x (gensym 0) )
            (y (dotimes (i (- val 1)) (gensym)) )

           )
             (gensym symbol-name) )
           (if symbol-name 
               (gensym symbol-name)
               (gensym)) ) )

(defun $= (x y) 
"Args: X Y
 A vectorized character comparison function.  Works like =, only for character arguments"
(map-elements #'equalp x y))
  
(defun string-position (stringa stringb)
"Args: string-a string-b
Returns position of first occurance of STRINGA in STRINGB or NIL otherwise. FWY"
  (let ((flag) 
        (location (position (char stringa 0) stringb :test #'equal)))
    (setf flag location)
    (if (and location (<= (length stringa) (length (subseq stringb location))))
        (dotimes (i (1- (length stringa)))
                 (setf flag (equal (select stringa (1+ i)) 
                                   (select stringb (+ location (1+ i))))))
        (setf flag nil))
    (if flag location nil)))

(defun search-string (string-a string-b)
"Args: STRING-A STRING-B
Search for first occurance of STRING-A (which must be a single character string) in STRING-B.  If found, return position index.  If not found, return nil. (Note that XLisp has no search function)."
  (let ((result nil)
        )
  (dotimes (i (length string-b))
           (when (char= (char string-a 0) (char string-b i))
                 (setf result i)
                 (return)))
    result))

(defun substitute-string (string-a string-b position)
"Args: STRING-A STRING-B POSITION
Substitute STRING-A into STRING-B at POSITION. (Note that XLisp has no substitute function)."
  (concatenate 'string 
               (subseq string-b 0 position)
               string-a
               (subseq string-b (+ position 1))))

(defun blanks-to-dashes (string)
"Arg: STRING
Convert all blanks in STRING to dashes, truncating terminating blank."
  (let ((position (search-string " " string))
        (new-string string))
    (cond 
      (position (setf new-string (substitute-string "-" string position))
                (when (equal "-" (subseq new-string (1- (length new-string))))
                      (setf new-string 
                            (subseq new-string 0 (1- (length new-string)))))
                (blanks-to-dashes new-string))
      (t string))))

(defun dashes-to-blanks (string)
"Arg: STRING
Convert all blanks in STRING to dashes, truncating terminating blank."
  (let ((position (search-string "-" string))
        (new-string string))
    (cond 
      (position (setf new-string (substitute-string " " string position))
                (when (equal " " (subseq new-string (1- (length new-string))))
                      (setf new-string 
                            (subseq new-string 0 (1- (length new-string)))))
                (dashes-to-blanks new-string))
      (t string))))

(defun remove-trailing-blanks (str)
    (if (equal #\Space (select (reverse str) 0))
        (remove-trailing-blanks (subseq str 0 (1- (length str))))
        str))

(defun remove-period (string)
"Args: STRING
Removes period and following characters from a string. Returns string up to period, or entire string if none. [function.lsp]"
  (let ((position (search-string "." string)))
    (if position (subseq string 0 position) string)))

(defun $position (string-a string-b)
"Args: (string-a string-b)
String-a and string-b are lists of strings.  Returns a list whose length
equals the number of occurances of the elements of string-a in string-b.  
The list contains the position of each element of string-a in string-b 
(ignoring the case of the strings).  If an element of string-a is not in 
string-b, a nil element is returned."
  (let ((positions nil)
        )
    (dotimes (i (length string-a))
             (setf positions 
                   (combine positions 
                            (which ($= (select string-a i) string-b)))))
    (rest positions)
    ))

(defun not2 (x) (map-elements #'not x))

(defun unique-values (input-list)
  (remove-duplicates input-list) )

;;next two functions redefined in displayw.lsp
;;file-to-stream  file-to-window

(defun make-matrix-list (matrix-list matrix)
"Args: MATRIX-LIST MATRIX
Adds MATRIX as a new element at the end of MATRIX-LIST."
  (let* ((n (length matrix-list))
         (new-matrix-list (make-list (+ 1 n) :initial-element nil)))
    (cond ((> n 0)
       (dotimes (i n)
                (setf (select new-matrix-list i) (select matrix-list i)))
       (setf (select new-matrix-list n) matrix))
      ((= n 0) (setf new-matrix-list (list matrix))))
    new-matrix-list))


(defun select2 (seq iseq)
"Args: Extends 3.46 select function to work on strings. Not needed for 3.50."
  (if (> xls-minor-release 49) (select seq iseq)
      (if iseq
          (if (sequencep iseq)
              (subseq seq (first iseq) (1+ (first (last iseq))))
              (select seq iseq))
          nil)))
#|can you believe this code (very very early on)?
(defun add-element-to-list (list element)
"Args: LIST ELEMENT
Adds ELEMENT as a new element to the end of LIST, creating a one element list when LIST is nil (there must be a much better way to do this)."
  (let* ((n (length list))
         (new-list (make-list (+ 1 n) :initial-element nil)))
    (cond ((> n 0)
           (dotimes (i n)
                    (setf (select new-list i) (select list i)))
           (setf (select new-list n) element))
      ((= n 0) (setf new-list (list element))))
    new-list))

;next doesn't work with display window...
(defun add-element-to-list (list element)
"Args: LIST ELEMENT
Replaces old function with new one based on cons."
  (setf list (cons element list)))
|#

(defun add-element-to-list (list element)
  (setf list (append list (list element))))


(defun sort-and-permute (sort-by-variable data-matrix &optional descending)
"Args: SORT-BY-VARIABLE DATA-MATRIX &optional DESCENDING
Sorts elements of SORT-BY-VARIABLE into ascending (DESCENDING if t) order and permutes all values in each column of DATA-MATRIX into corresponding order. Returns list of permuted data."
  (let ((labels (iseq (length sort-by-variable))))
    (first (sort-and-permute-dob 
            data-matrix labels sort-by-variable descending))))

(defun sort-and-permute-dob (data-matrix labels sort-by-variable descending)
"Args: DATA-MATRIX LABELS SORT-BY-VARIABLE DESCENDING
Sorts elements of SORT-BY-VARIABLE into ascending (DESCENDING if t) order and permutes LABELS and all columns in DATA-MATRIX into corresponding order. Returns list of permuted data-matrix, permuted labels, and sorted sort-by-variable."
  (let* ((rows-of-data-matrix (row-list data-matrix))
         (order-var (order sort-by-variable))
         (permuted-data nil)
         (permuted-labels nil)
         (permuted-data-matrix nil)) 
    (when descending (setf order-var (reverse order-var)))
    (setf permuted-data (select rows-of-data-matrix order-var))
    (setf permuted-labels (select labels order-var))
    (setf permuted-data-matrix (matrix (size data-matrix)
                                       (combine permuted-data)))
    (list permuted-data-matrix permuted-labels order-var)))


(defun rank-with-ties (sequence)
"Args: sequence
Ranks elements in sequence, creating mean rank for tied elements. Ranks are 1-based so that lowest rank is 1 (not 0)"
  (let* ((ordered (select sequence (order (rank sequence))))
         (n (length ordered))
         (ntied 1)
         (ranksum 1)
         (meanrank nil)
         (tiedranks (repeat nil n))
         (k 0)
         )
    (dotimes (i n) 
             (cond
               ((= i (- n 1))
                (setf meanrank (/ ranksum ntied))
                (dotimes (j ntied)
                         (setf (select tiedranks k) meanrank)
                         (setf k (1+ k))))
               ((= (select ordered i) (select ordered (1+ i)))
                (setf ntied (1+ ntied))
                (setf ranksum (+ ranksum i 2)))
               (t
                (setf meanrank (/ ranksum ntied))
                (dotimes (j ntied)
                         (setf (select tiedranks k) meanrank)
                         (setf k (1+ k)))
                (setf ntied 1)
                (setf ranksum (+ 2 i)))))
    
    (select tiedranks (rank sequence)) )) ; fwy 4.28
;was(- (select tiedranks (rank sequence)) 1))) 


(defun string-downcase-if-not-X11 (string)
"Function Args: string
Does string downcase if the X11 feature not present"
#-X11 (string-downcase string)
#+X[11 string
  )

;******* SYSTEM FUNCTIONS ***********




;revised fwy 20010402,20010418,20010926
(defun msw-exit (&rest args) (apply #'vista-exit args))

(defun vista-exit (&optional sure? compile)
  (when (and (not *pro-version*) *devel-mode*)
        (setf *devel-mode* nil))
  (remove-help)
  (set-ini-exit-states)
  (when *starter* (restore-prefs-files))
  ;(save-every-pref-file);updates all files in prefs directory 
  (when (and *devel-mode* *force-user-mode*)
        (let ((tbd (three-button-dialog "Switch back to Developer Mode?"
                                 :first-button "Yes. Please!" 
                                 :second-button "No, Thanks!"
	                           :third-button "No! Dont Ask!")))
          (case tbd
            (0 (setf *pro-version* t)
               (setf *force-user-mode* nil))
            (1 (setf *pro-version* nil)
               (setf *force-user-mode* t))
            (2 (setf *pro-version* nil)
               (setf *force-user-mode* nil)))))
  (save-environment)
  (save-seven-values)
  (when *devel-mode* 
        (ignore-errors (load (strcat *devel-path* "developer.lsp"))))
  (cond 
    (compile (make-vista :exit t))
    (*pro-version*  (make-vista :exit t)) ;(compile-exit)
    ((send *vista* :exit-style)
     (when (two-button-dialog (format nil "Do You Really Want To Exit?")
                        :title "EXIT VISTA!"
                        :first-button "YES - PLEASE EXIT"
                        :second-button "NO - DO NOT EXIT")
           (exit)))
    (t (exit)))
  )

(defun set-ini-exit-states ()
  (msw-write-profile-string "ViSta" "ViStaOp" "No"
                            (strcat *default-path* "wxls32.ini"))
  (msw-write-profile-string "ViSta" "ViStaRunning" "No"
                            (strcat *default-path* "wxls32.ini"))
  (msw-write-profile-string "ViSta" "InFile" "No"
                            (strcat *default-path* "wxls32.ini"))
  (msw-write-profile-string "ViSta" "LispBossStartedViSta" "No"
                            (strcat *default-path* "wxls32.ini"))
  (msw-write-profile-string "ViSta" "LispBossRunning" "No"
                            (strcat *default-path* "wxls32.ini"))
  (msw-write-profile-string  "ViSta" "Verbosity" (format nil "~a" *verbosity*) 
                             (strcat *default-path* "wxls32.ini"))
  )

(defun remove-help ()
  (let ((windows 
         (list *help-control-panel* *welcome-control-panel*
                       *MENU-ITEM-HELP-CONTROL-PANEL* *help-window* *please-wait*)))
    (if windows
        (mapcar #'(lambda (object)
                    (if object (ignore-errors (send object :remove))))
                windows))))

(defun flying-exit ()(vista-exit))

;the following close functions probably are not used

(defun close-exit ()(vista-exit t))

(defun quit ()
 (cond 
   (*current-object* 
    (when (send (save-exit-dialog-box) :modal-dialog)
          (exit)))
   (t
    (prepare-to-quit)
    (exit))))

(defun save-exit ()
"Changes Quit or Exit to present warning dialog box"
  (let (
#+macintosh (exit-item (- (length (send *file-menu* :items)) 1))
#+msdos     (exit-item  3)
#+X11       (exit-item  10)
        )
    (send *file-menu* :delete-items
          (select (send *file-menu* :items) exit-item))
    (send *file-menu* :append-items
          (send menu-item-proto :new "Quit" :key #\Q 
                :action #'(lambda () (quit) )
                ))))


(defun save-exit-dialog-box () 
      (let* ((text1 (send text-item-proto :new
                    "Save ViSta data or models?"))
#-msdos(quit-exit-string "Quit")
#+msdos(quit-exit-string "Exit")
             (text2 (send text-item-proto :new (format nil
                   "(To Save, click Save, then~%use the save menu items.)")))
             (quit (send modal-button-proto :new quit-exit-string :action 
                     #'(lambda ()
                         (prepare-to-quit)
                         t)
                         ))
             (save (send modal-button-proto :new "Save" )))
        (send modal-dialog-proto :new
              (list text1 (list save quit) text2)
              :default-button save)))

(defun prepare-to-quit ()
  (close-all-plots)
  (when (send *vista* :help-window-object)
        (send (send *vista* :help-window-object) 
              :close)
        (send *vista* :help-window-object nil))
  (let* ((win-list 
          (send *vista* :report-window-id-list))
         (nw (length win-list))) 
    (when win-list
          (dotimes 
           (i nw)
           (send (select win-list i) :remove))))
  )

(defun move-listener ()
  (send *listener*  :hide-window)
  (send *listener*  :flush-window)
  (apply #'send *listener*  :size '(490 90))
  (apply #'send *listener*  :location *text-window-location*)
  (send *listener* :title "LispStat")
  (princ about)
  (terpri)
  (show-Xlisp-Stat))






(provide "function")